home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / csdtpckr / msubcls.bas < prev    next >
BASIC Source File  |  1998-10-31  |  10KB  |  282 lines
  1. Attribute VB_Name = "modSubClass"
  2. Option Explicit
  3. '
  4. Public Const GWL_USERDATA = (-21)
  5. Public Const GWL_WNDPROC = -4
  6. Public Const GWL_STYLE = (-16)
  7. '
  8. Public Const WS_CHILD = &H40000000
  9. Public Const WS_VISIBLE = &H10000000
  10. Public Const WS_DISABLED = &H8000000
  11. '
  12. Public Const WM_DESTROY = &H2
  13. Public Const WM_SETFONT = &H30
  14. Public Const WM_NOTIFY = &H4E
  15. Public Const WM_CHAR = &H102
  16. Public Const WM_RBUTTONUP = &H205
  17. Public Const WM_LBUTTONDOWN = &H201
  18. '
  19. Public Const GDT_ERROR = -1&
  20. Public Const GDT_VALID = 0&
  21. '
  22. Public Const DTN_FIRST As Long = -760
  23. Public Const MCM_FIRST = &H1000&
  24. Public Const DTM_FIRST = &H1000&
  25. '
  26. Private Const DTM_GETSYSTEMTIME = (DTM_FIRST + 1)
  27. Private Const DTM_GETMONTHCAL = (DTM_FIRST + 8)
  28. '
  29. Private Const DTN_DATETIMECHANGE = (DTN_FIRST + 1) ' // the systemtime has changed
  30. Private Const DTN_DROPDOWN = (DTN_FIRST + 6) '       // MonthCal has dropped down
  31. Private Const DTN_CLOSEUP = (DTN_FIRST + 7) '        // MonthCal is popping up
  32. ' // set first day of week to iDay:
  33. ' // 0 = Monday, ..., 6 = Sunday // -1 = use locale
  34. Private Const MCM_SETFIRSTDAYOFWEEK = (MCM_FIRST + 15)
  35. Private Const MCM_GETFIRSTDAYOFWEEK = (MCM_FIRST + 16)
  36. '
  37. Private Const MCS_WEEKNUMBERS = &H4
  38. Private Const MCS_NOTODAYCIRCLE = &H8
  39. Private Const MCS_NOTODAY = &H10
  40. '
  41. Public Type RECT
  42.         Left As Long
  43.         Top As Long
  44.         Right As Long
  45.         Bottom As Long
  46. End Type
  47. '
  48. Public Type SYSTEMTIME
  49.     wYear As Integer
  50.     wMonth As Integer
  51.     wDayOfWeek As Integer
  52.     wDay As Integer
  53.     wHour As Integer
  54.     wMinute As Integer
  55.     wSecond As Integer
  56.     wMilliseconds As Integer
  57. End Type
  58. '
  59. Public Type NMHDR
  60.     hwndFrom As Long
  61.     idfrom As Long
  62.     code As Long
  63. End Type
  64. '
  65. Public Type NMDATETIMECHANGE
  66.     NMHDR As NMHDR
  67.     dwFlags As Long
  68.     st As SYSTEMTIME
  69. End Type
  70. '
  71. Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal uMgs As Long, ByVal wParam As Long, lParam As Any) As Long
  72. Public Declare Function apiSetFocus Lib "user32" Alias "SetFocus" (ByVal hwnd As Long) As Long
  73. Public Declare Function apiGetFocus Lib "user32" Alias "GetFocus" () As Long
  74. Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
  75. Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Any) As Long
  76. Public Declare Function SetParent Lib "user32" (ByVal hWndChild As Long, ByVal hWndNewParent As Long) As Long
  77. '
  78. Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal wndrpcPrev As Long, ByVal hwnd As Long, ByVal uMsg As Long, ByVal wParam As Long, lParam As Any) As Long
  79. Private Declare Function IsWindow Lib "user32" (ByVal hwnd As Long) As Long
  80. Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
  81. Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
  82. '
  83. Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSrc As Any, ByVal ByteLen As Long)
  84. '
  85. Private Declare Sub OleTranslateColor Lib "oleaut32.dll" (ByVal ColorIn As Long, ByVal hPal As Long, ByRef RGBColorOut As Long)
  86. '
  87. '
  88. ' Use to track Multiple DatePicker controls and their subclassing
  89. '
  90. Public scCollection As New Collection
  91. '
  92. ' This function is used to allow the user to right click
  93. ' on the background of the date-picker, and switch between
  94. ' displaying the dropdown button or the spin button
  95. '
  96. Public Function ToggleWinProc(ByVal hwnd As Long, ByVal uMsg As Long, _
  97.                         ByVal wParam As Long, ByVal lParam As Long) As Long
  98. '
  99.     Dim mcObj As Object
  100. '
  101.     On Error Resume Next
  102.     Set mcObj = scCollection.Item("U" & Hex(hwnd))
  103.     If mcObj Is Nothing Then Exit Function
  104.     On Error GoTo 0
  105. '
  106.     Select Case uMsg
  107.     Case WM_RBUTTONUP
  108.     
  109.         mcObj.UpDown = Not mcObj.UpDown
  110.     
  111.     Case WM_LBUTTONDOWN
  112.         
  113.         If apiGetFocus <> mcObj.hwnd Then apiSetFocus mcObj.hwnd
  114.     
  115.     Case WM_CHAR
  116.     
  117.         If mcObj.hwnd > 0 Then
  118.             ' Pass through keys after setting focus to the user control
  119.             ' This handles tabs, shift-tabs, returns, etc.
  120.             ' (if not already focused)
  121.             If apiGetFocus <> hwnd Then
  122.                 apiSetFocus mcObj.hwnd
  123.                 SendKeys Chr$(wParam)
  124.             End If
  125.             
  126.         End If
  127.         Exit Function
  128.     
  129.     Case WM_DESTROY
  130.         
  131.         If mcObj.HWndUCProc <> 0 Then
  132.             SetWindowLong hwnd, GWL_WNDPROC, CLng(mcObj.HWndUCProc)
  133.         Else
  134.             SetWindowLong hwnd, GWL_WNDPROC, 0&
  135.             Exit Function
  136.         End If
  137.     
  138.     End Select
  139.     
  140.     If mcObj.HWndUCProc <> 0 And CBool(IsWindow(hwnd)) Then
  141.         ToggleWinProc = CallWindowProc(mcObj.HWndUCProc, hwnd, uMsg, wParam, ByVal lParam)
  142.     End If
  143.     
  144. End Function
  145. '
  146. Public Function ChangeWinProc(ByVal hwnd As Long, ByVal uMsg As Long, _
  147.                         ByVal wParam As Long, ByVal lParam As Long) As Long
  148. '
  149.     Dim mcNmHdr As NMHDR
  150.     Dim mcNmDTC As NMDATETIMECHANGE
  151.     Dim mcObj As Object
  152.     Dim mlHwnd As Long
  153.     Dim mlStyle As Long
  154.     Dim mlRect As RECT
  155. '
  156.     On Error Resume Next
  157.     Set mcObj = scCollection.Item("H" & Hex(hwnd))
  158.     If mcObj Is Nothing Then Exit Function
  159.     On Error GoTo 0
  160. '
  161.     Select Case uMsg
  162.     Case WM_NOTIFY
  163.         
  164.         CopyMemory mcNmHdr, ByVal lParam, Len(mcNmHdr)
  165.             
  166.         Select Case mcNmHdr.code
  167.         Case DTN_DROPDOWN
  168.         
  169.             If mcObj.HWndDP > 0 Then
  170.                 
  171.                 mlHwnd = SendMessage(mcObj.HWndDP, DTM_GETMONTHCAL, 0&, ByVal 0&)
  172.         
  173.                 If mlHwnd > 0 Then
  174.                     
  175.                     ' Set the first day of week for the dropdown calendar
  176.                     SendMessage mlHwnd, MCM_SETFIRSTDAYOFWEEK, _
  177.                         0, ByVal FDOW(mcObj.FirstDayOfWeek)
  178.                     
  179.                     GetWindowRect mlHwnd, mlRect
  180.                     
  181.                     ' Get the current style bits
  182.                     mlStyle = GetWindowLong(mlHwnd, GWL_STYLE)
  183.                     
  184.                     ' Show Week Numbers
  185.                     mlStyle = mlStyle Or IIf(mcObj.ShowWeeks, MCS_WEEKNUMBERS, 0)
  186.                     mlRect.Right = (mlRect.Right - mlRect.Left) * _
  187.                                 IIf(mcObj.ShowWeeks, 1.15, 1)
  188.                     ' Hide today circle and today date
  189.                     mlStyle = mlStyle Or IIf(Not mcObj.ShowToday, (MCS_NOTODAYCIRCLE Or MCS_NOTODAY), 0)
  190.                     mlRect.Bottom = (mlRect.Bottom - mlRect.Top) * _
  191.                                  IIf(Not mcObj.ShowToday, 0.92, 1)
  192.                     
  193.                     ' Set the modified style bits
  194.                     SetWindowLong mlHwnd, GWL_STYLE, mlStyle
  195.  
  196.                     MoveWindow mlHwnd, mlRect.Left, mlRect.Top, _
  197.                             mlRect.Right, mlRect.Bottom, True
  198.                     
  199.                     ' This doevents appears to be needed to handle
  200.                     ' the case where focus is given to the control
  201.                     ' and the dropdown is shown at the same time
  202.                     DoEvents
  203.                     
  204.                     If apiGetFocus <> hwnd Then apiSetFocus hwnd
  205.                     
  206.                 End If
  207.                 
  208.             End If
  209.         
  210.         Case DTN_CLOSEUP
  211.         
  212.             If mcObj.HWndDP <> apiGetFocus Then apiSetFocus mcObj.HWndDP
  213.         
  214.         Case DTN_DATETIMECHANGE
  215.             ' Whenever the datepicker date changes this
  216.             ' message is processed.
  217.             CopyMemory mcNmDTC, ByVal lParam, Len(mcNmDTC)
  218.             ' if the flag = GDT_VALID, then save the date
  219.             If mcNmDTC.dwFlags = GDT_VALID Then
  220.                 mcObj.HWndValue = GetDate(mcNmDTC.st)
  221.             End If
  222.         
  223.         End Select
  224.         
  225.     Case WM_DE